home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Environments / PowerLisp 2.01 / PowerLisp 2.01 ƒ / Library / format.lisp < prev    next >
Lisp/Scheme  |  1996-05-17  |  22KB  |  706 lines
  1. ;;;
  2. ;;;        PowerLisp 2.0
  3. ;;;        Copyright © 1996 Roger Corman.  All rights reserved.
  4. ;;;
  5. ;;;
  6. ;;;        Common Lisp 'format' function.
  7. ;;;
  8. (in-package :common-lisp)
  9. (provide :format)
  10.  
  11. (defun format (dest control-string &rest arguments)
  12.     (let ((return-value nil) (%debug nil))
  13.         ;; check for dest equal to t or nil
  14.         (cond 
  15.             ((null dest) 
  16.              (progn 
  17.                 (setf dest (make-string-output-stream))
  18.                 (setf return-value dest)))
  19.             ((eq dest t) (setf dest *standard-output*)))
  20.         (catch '%format-up-and-out
  21.             (%format-list dest control-string arguments))
  22.         (if return-value (get-output-stream-string return-value))))
  23.  
  24. (defun %format-list (dest control-string arguments)
  25.     ;; scan control string and dispatch to output functions
  26.     (do ((index 0)
  27.          (arg-index 0)
  28.          (length (length control-string))
  29.          (atsign-modifier nil nil)
  30.          (colon-modifier nil nil)
  31.          dispatch-func
  32.          (parameters nil)
  33.          control
  34.          char)
  35.         ((>= index length) arg-index)
  36.         (setf char (char control-string index))
  37.         (if (char= char #\~)
  38.             ;; process directive
  39.             (progn
  40.                 ;; get parameters
  41.                 (incf index)
  42.                 (multiple-value-setq (parameters index) 
  43.                     (%get-params control-string index))
  44.     
  45.                 ;; check for modifiers
  46.                 (dotimes (i 2)
  47.                     (if (>= index length) (return))
  48.                     (setq char (char control-string index))
  49.                     (if (char= char #\@)
  50.                         (setq atsign-modifier t)
  51.                         (if (char= char #\:)
  52.                             (setq colon-modifier t)
  53.                             (return)))
  54.                     (incf index))
  55.  
  56.                 ;; the next character should be the format
  57.                 ;; directive character
  58.                 (if (>= index length)
  59.                     (error "Invalid format directive: ~A" control-string))
  60.                 (setq char (char control-string index))
  61.                 (incf index)
  62.                 (setf dispatch-func 
  63.                     (%get-format-dispatch-func char))
  64.                 (if (null dispatch-func)
  65.                     (error "Invalid format directive : ~A" control-string))
  66.                 (setq control (list control-string index))
  67.                 (setq arg-index 
  68.                     (apply dispatch-func 
  69.                         dest 
  70.                         arguments arg-index 
  71.                         atsign-modifier colon-modifier 
  72.                         control
  73.                         parameters))
  74.                 (setq index (cadr control)))         
  75.  
  76.             ;; just output the character
  77.             (progn
  78.                 (write-char char dest)
  79.                 (incf index)))))
  80.  
  81.  
  82. ;;;
  83. ;;;
  84. ;;;    Returns two values: the list of params found and the
  85. ;;; updated index.
  86. ;;
  87. (defun %get-params (control-string index &aux (params nil))
  88.     (do (int
  89.          c
  90.          (length (length control-string)))
  91.         ((>= index length))
  92.         (if (char= (char control-string index) #\Newline)
  93.             (return))
  94.         (multiple-value-setq (int index) 
  95.             (parse-integer control-string :start index
  96.                 :junk-allowed t))
  97.         (setq c (char control-string index))
  98.         (if int 
  99.             (push int params)
  100.             (if (char= c #\,) 
  101.                 (push nil params)))
  102.         (if (char= c #\,) (incf index) (return)))
  103.     (values (nreverse params) index))
  104.         
  105. ;;; Format dispatch functions take a stream, argument list,
  106. ;;; @-modifier and :-modifier arguments, followed by any passed
  107. ;;; parameters. Any passed parameters which are nil should be
  108. ;;; assumed to be requesting the default. The dispatch functions
  109. ;;; should return the remaining argument list (missing the
  110. ;;; arguments that they processed.
  111. ;;;
  112.  
  113. (defvar *format-functions* #256())
  114.  
  115. (defun %set-format-dispatch-func (char func)
  116.     (let ((index (char-code (char-upcase char))))
  117.         (setf (elt *format-functions* index) func)))
  118.  
  119. (defun %get-format-dispatch-func (char)
  120.     (let ((index (char-code (char-upcase char))))
  121.         (elt *format-functions* index)))
  122.  
  123. (%set-format-dispatch-func #\A 
  124.     #'(lambda (stream args index atsign-modifier colon-modifier control
  125.                 &optional mincol colinc 
  126.                         minpad padchar)
  127.         (setq args (nthcdr index args))
  128.         (if (null args) 
  129.             (error "Not enough args for ~AA format directive" #\~))
  130.  
  131.         ;; initialize defaults
  132.         (unless mincol (setq mincol 0))
  133.         (unless colinc (setq colinc 1))
  134.         (unless minpad (setq minpad 0))
  135.         (setq padchar (if padchar (int-char padchar) #\Space))
  136.  
  137.         (let ((*print-escape* nil)
  138.                 (arg (car args)))
  139.             (if (and (null arg) colon-modifier)
  140.                 (setq arg "()"))
  141.             (if atsign-modifier
  142.                 ;; needto output to string to insert padding in front
  143.                 (let ((s (with-output-to-string (x) (princ arg x))) 
  144.                       length)
  145.                     (dotimes (i minpad) (write-char padchar stream))
  146.                     (setq length (length s))
  147.                      (incf length minpad)
  148.                     (do ()
  149.                         ((>= length mincol))
  150.                         (dotimes (i colinc) (write-char padchar stream))
  151.                         (incf length colinc))
  152.                     (princ s stream))
  153.                 (let (length (start-pos (stream-column stream)))
  154.                     (princ arg stream)
  155.                     (setq length (- (stream-column stream) start-pos))
  156.                     (if (< length 0) (setq length 0))
  157.                     (dotimes (i minpad) (write-char padchar stream))
  158.                      (incf length minpad)
  159.                     (do ()
  160.                         ((>= length mincol))
  161.                         (dotimes (i colinc) (write-char padchar stream))
  162.                         (incf length colinc)))))
  163.             (1+ index)))
  164.  
  165. (%set-format-dispatch-func #\S 
  166.     #'(lambda (stream args index atsign-modifier colon-modifier control
  167.                 &optional mincol colinc 
  168.                         minpad padchar)
  169.         (setq args (nthcdr index args))
  170.         (if (null args) 
  171.             (error "Not enough args for ~AS format directive" #\~))
  172.  
  173.         ;; initialize defaults
  174.         (unless mincol (setq mincol 0))
  175.         (unless colinc (setq colinc 1))
  176.         (unless minpad (setq minpad 0))
  177.         (setq padchar (if padchar (int-char padchar) #\Space))
  178.  
  179.         (let ((*print-escape* t)
  180.                 (arg (car args)))
  181.             (if (and (null arg) colon-modifier)
  182.                 (setq arg "()"))
  183.             (if atsign-modifier
  184.                 ;; need to output to string to insert padding in front
  185.                 (let ((s (with-output-to-string (x) (prin1 arg x))) 
  186.                       length)
  187.                     (dotimes (i minpad) (write-char padchar stream))
  188.                     (setq length (length s))
  189.                      (incf length minpad)
  190.                     (do ()
  191.                         ((>= length mincol))
  192.                         (dotimes (i colinc) (write-char padchar stream))
  193.                         (incf length colinc))
  194.                     (princ s stream))
  195.                 (let (length (start-pos (stream-column stream)))
  196.                     (prin1 arg stream)
  197.                     (setq length (- (stream-column stream) start-pos))
  198.                     (if (< length 0) (setq length 0))
  199.                     (dotimes (i minpad) (write-char padchar stream))
  200.                      (incf length minpad)
  201.                     (do ()
  202.                         ((>= length mincol))
  203.                         (dotimes (i colinc) (write-char padchar stream))
  204.                         (incf length colinc)))))
  205.             (1+ index)))
  206.  
  207. (%set-format-dispatch-func #\D 
  208.     #'(lambda (stream args index atsign-modifier colon-modifier control 
  209.                 &optional mincol padchar commachar)
  210.         (setq args (nthcdr index args))
  211.         (if (null args) 
  212.             (error "Not enough args for ~~D format directive"))
  213.  
  214.         ;; if not an integer use ~A output
  215.         (if (not (integerp (car args)))
  216.             (let ((*print-base* 10))
  217.                 (return (apply (%get-format-dispatch-func #\A)
  218.                         stream args atsign-modifier
  219.                         colon-modifier mincol nil nil padchar))))
  220.  
  221.         (%format-integer stream (car args) 10 atsign-modifier colon-modifier
  222.                 mincol padchar commachar)
  223.         (1+ index)))
  224.  
  225. (%set-format-dispatch-func #\B 
  226.     #'(lambda (stream args index atsign-modifier colon-modifier control 
  227.                 &optional mincol padchar commachar)
  228.         (setq args (nthcdr index args))
  229.         (if (null args) 
  230.             (error "Not enough args for ~AB format directive" #\~))
  231.  
  232.         ;; if not an integer use ~A output
  233.         (if (not (integerp (car args)))
  234.             (let ((*print-base* 2))
  235.                 (return (apply (%get-format-dispatch-func #\A)
  236.                         stream args atsign-modifier
  237.                         colon-modifier mincol nil nil padchar))))
  238.  
  239.         (%format-integer stream (car args) 2 atsign-modifier colon-modifier
  240.                 mincol padchar commachar)
  241.         (1+ index)))
  242.  
  243. (%set-format-dispatch-func #\O 
  244.     #'(lambda (stream args index atsign-modifier colon-modifier control 
  245.                 &optional mincol padchar commachar)
  246.         (setq args (nthcdr index args))
  247.         (if (null args) 
  248.             (error "Not enough args for ~AO format directive" #\~))
  249.  
  250.         ;; if not an integer use ~A output
  251.         (if (not (integerp (car args)))
  252.             (let ((*print-base* 8))
  253.                 (return (apply (%get-format-dispatch-func #\A)
  254.                         stream args atsign-modifier
  255.                         colon-modifier mincol nil nil padchar))))
  256.  
  257.         (%format-integer stream (car args) 8 atsign-modifier colon-modifier
  258.                 mincol padchar commachar)
  259.         (1+ index)))
  260.  
  261. (%set-format-dispatch-func #\X 
  262.     #'(lambda (stream args index atsign-modifier colon-modifier control 
  263.                 &optional mincol padchar commachar)
  264.         (setq args (nthcdr index args))
  265.         (if (null args) 
  266.             (error "Not enough args for ~AX format directive" #\~))
  267.  
  268.         ;; if not an integer use ~A output
  269.         (if (not (integerp (car args)))
  270.             (let ((*print-base* 16))
  271.                 (return (apply (%get-format-dispatch-func #\A)
  272.                         stream args atsign-modifier
  273.                         colon-modifier mincol nil nil padchar))))
  274.  
  275.         (%format-integer stream (car args) 16 atsign-modifier colon-modifier
  276.                 mincol padchar commachar)
  277.         (1+ index)))
  278.  
  279. (%set-format-dispatch-func #\R 
  280.     #'(lambda (stream args index atsign-modifier colon-modifier control 
  281.                 &optional radix mincol padchar commachar)
  282.         (setq args (nthcdr index args))
  283.         (if (null args) 
  284.             (error "Not enough args for ~AR format directive" #\~))
  285.         
  286.         (if radix
  287.             ;; if not an integer use ~A output
  288.             (progn
  289.                 (if (not (integerp (car args)))
  290.                     (let ((*print-base* radix))
  291.                         (return (apply (%get-format-dispatch-func #\A)
  292.                                     args atsign-modifier
  293.                                     colon-modifier mincol nil nil padchar))))
  294.                 (unless (and (plusp radix) (<= radix 36))
  295.                     (error "Invalid radix specified: ~A" radix))
  296.                 (%format-integer stream (car args) radix atsign-modifier colon-modifier
  297.                     mincol padchar commachar))
  298.             (progn
  299.                 (if (not (integerp (car args)))
  300.                     (return (apply (%get-format-dispatch-func #\A)
  301.                                     args atsign-modifier
  302.                                     colon-modifier mincol nil nil padchar)))
  303.                 (cond
  304.                     ((and atsign-modifier colon-modifier) 
  305.                       (%format-old-roman-numeral (car args) stream))
  306.                     (atsign-modifier (%format-roman-numeral (car args) stream))
  307.                     (colon-modifier (%format-ordinal-number (car args) stream))
  308.                     (t (%format-cardinal-number (car args) stream)))))
  309.         (1+ index)))
  310.  
  311. (%set-format-dispatch-func #\~ 
  312.     #'(lambda (stream args index atsign-modifier colon-modifier control 
  313.                 &optional num)
  314.         (unless num (setq num 1))
  315.         (dotimes (i num)
  316.             (write-char #\~ stream))
  317.         index))
  318.  
  319. (%set-format-dispatch-func #\% 
  320.     #'(lambda (stream args index atsign-modifier colon-modifier control 
  321.                 &optional num)
  322.         (unless num (setq num 1))
  323.         (dotimes (i num)
  324.             (write-char #\Newline stream))
  325.         index))
  326.  
  327. (%set-format-dispatch-func #\F 
  328.     #'(lambda (stream args index atsign-modifier colon-modifier control 
  329.                 &optional width digits scale overflow-char padchar)
  330.         (setq args (nthcdr index args))
  331.         (if (null args) 
  332.             (error "Not enough args for ~~F format directive"))
  333.  
  334.         ;; initialize defaults
  335.         (unless width (setq width -1))
  336.         (unless digits (setq digits 1))
  337.         (unless scale (setq scale 0))
  338.         (setq overflow-char (if overflow-char (int-char overflow-char) #\Space))
  339.         (setq padchar (if padchar (int-char padchar) #\Space))
  340.  
  341.         (print-float (car args) stream :fixed width digits
  342.                 scale padchar atsign-modifier)
  343.         (1+ index)))
  344.  
  345. (%set-format-dispatch-func #\G 
  346.     #'(lambda (stream args index atsign-modifier colon-modifier control 
  347.                 &optional width digits exp-digits scale overflow-char padchar
  348.                     exponent-char)
  349.         (setq args (nthcdr index args))
  350.         (if (null args) 
  351.             (error "Not enough args for ~~G format directive"))
  352.  
  353.         ;; initialize defaults
  354.         (unless width (setq width -1))
  355.         (unless digits (setq digits 1))
  356.         (unless exp-digits (setq exp-digits 2))
  357.         (unless scale (setq scale 0))
  358.         (setq overflow-char (if overflow-char (int-char overflow-char) #\Space))
  359.         (setq padchar (if padchar (int-char padchar) #\Space))
  360.         (setq exponent-char (if exponent-char (int-char exponent-char) #\E))
  361.  
  362.         (print-float (car args) stream :general width digits
  363.                 scale padchar atsign-modifier)
  364.         (1+ index)))
  365.  
  366. (%set-format-dispatch-func #\E 
  367.     #'(lambda (stream args index atsign-modifier colon-modifier control 
  368.                 &optional width digits exp-digits scale overflow-char padchar
  369.                     exponent-char)
  370.         (setq args (nthcdr index args))
  371.         (if (null args) 
  372.             (error "Not enough args for ~~E format directive"))
  373.  
  374.         ;; initialize defaults
  375.         (unless width (setq width -1))
  376.         (unless digits (setq digits 1))
  377.         (unless exp-digits (setq exp-digits 2))
  378.         (unless scale (setq scale 0))
  379.         (setq overflow-char (if overflow-char (int-char overflow-char) #\Space))
  380.         (setq padchar (if padchar (int-char padchar) #\Space))
  381.         (setq exponent-char (if exponent-char (int-char exponent-char) #\E))
  382.  
  383.         (print-float (car args) stream :exponential width digits
  384.                 scale padchar atsign-modifier)
  385.         (1+ index)))
  386.  
  387. (%set-format-dispatch-func #\{ 
  388.     #'(lambda (stream args index atsign-modifier colon-modifier control)
  389.         (setq args (nthcdr index args))
  390.         (unless args 
  391.             (error "Not enough args for ~~{ format directive"))
  392.         (unless (or (listp (car args)) atsign-modifier)
  393.             (error "Invalid format argument--should be a list"))
  394.  
  395.         (let ((end-brace-index (search "~}" (car control) :start2 (cadr control)))
  396.               string)
  397.             (if end-brace-index
  398.                 (setq string (subseq (car control) (cadr control) end-brace-index))
  399.                 (error "Missing ~~} following ~{ in format string"))
  400.             (setf (cadr control) (+ 2 end-brace-index))
  401.             (cond 
  402.                 ((and colon-modifier atsign-modifier)
  403.                     (return 
  404.                         (do ((arg-index 0))
  405.                             ((>= arg-index (length args)) (+ index arg-index))
  406.                             (%format-list stream string (nth arg-index args))
  407.                             (incf arg-index))))
  408.                 (colon-modifier
  409.                     (return
  410.                         (do ((arg-index 0))
  411.                             ((>= arg-index (length (car args))) (1+ index))
  412.                             (%format-list stream string (nth arg-index (car args)))
  413.                             (incf arg-index))))
  414.                 (atsign-modifier                     
  415.                     (return 
  416.                         (do ((arg-index 0))
  417.                             ((>= arg-index (length args)) (+ index arg-index))
  418.                             (incf arg-index 
  419.                                 (%format-list stream string (nthcdr arg-index args))))))
  420.                 (t 
  421.                     (catch '%format-up-and-out
  422.                         (do ((arg-index 0))
  423.                             ((>= arg-index (length (car args))) (1+ index))
  424.                             (incf arg-index 
  425.                                 (%format-list stream string 
  426.                                     (nthcdr arg-index (car args))))))
  427.                     (1+ index))))))
  428.  
  429. ;; case conversion
  430. (%set-format-dispatch-func #\( 
  431.     #'(lambda (stream args index atsign-modifier colon-modifier control)
  432.         (setq args (nthcdr index args))        ;; skip unnecessary arguments
  433.  
  434.         ;; collect the characters up until a closing parentheses
  435.         (let ((close-paren-index (search "~)" (car control) :start2 (cadr control)))
  436.               string
  437.               (string-stream (make-string-output-stream)))
  438.             (if close-paren-index
  439.                 (setq string (subseq (car control) (cadr control) close-paren-index))
  440.                 (error "Missing ~~) following ~( in format string"))
  441.             (setf (cadr control) (+ 2 close-paren-index))
  442.             (setf index (%format-list string-stream string args))
  443.             (setq string (get-output-stream-string string-stream))
  444.             (cond 
  445.                 ((and colon-modifier atsign-modifier)
  446.                     (progn
  447.                         (setq string (string-upcase string))
  448.                         (write-string string stream)
  449.                         (return index)))
  450.                 (colon-modifier
  451.                     (progn
  452.                         (setq string (string-capitalize string))
  453.                         (write-string string stream)
  454.                         (return index)))
  455.                 ;; need to fix this to only capitalize the first word
  456.                 (atsign-modifier                     
  457.                     (progn
  458.                         (setq string (string-capitalize string))
  459.                         (write-string string stream)
  460.                         (return index)))
  461.                 (t 
  462.                     (progn
  463.                         (setq string (string-downcase string))
  464.                         (write-string string stream)
  465.                         (return index)))))))
  466.  
  467. ;; using the string between the ~[ and ~], return a list of the
  468. ;; control strings separated by ~;
  469. (defun %expr-list (string)
  470.     (do ((size (length string))
  471.           (ret nil)
  472.           semicolon-index
  473.           new-string
  474.           (position 0))
  475.         ((>= position size) (nreverse ret))
  476.         (setq semicolon-index (search "~;" string :start2 position))
  477.         (if (null semicolon-index)
  478.             (setq semicolon-index size))
  479.         
  480.         (setq new-string (subseq string position semicolon-index))
  481.         (setq ret (cons new-string ret))
  482.         (setq position (+ semicolon-index 2))))
  483.                 
  484. ;; conditional expressions
  485. (%set-format-dispatch-func #\[ 
  486.     #'(lambda (stream args index atsign-modifier colon-modifier control)
  487.         (setq args (nthcdr index args))        ;; skip unnecessary arguments
  488.  
  489.         (if (null args) 
  490.             (error "Not enough args for ~~[ format directive"))
  491.  
  492.         ;; collect the characters up until a closing brace
  493.         (let ((close-brace-index (search "~]" (car control) :start2 (cadr control)))
  494.               string
  495.               conditional-exprs
  496.               selector
  497.               (string-stream (make-string-output-stream)))
  498.             (if close-brace-index
  499.                 (setq string (subseq (car control) (cadr control) close-brace-index))
  500.                 (error "Missing ~~] following ~[ in format string"))
  501.             (setf (cadr control) (+ 2 close-brace-index))
  502.             (setf conditional-exprs (%expr-list string))
  503.             (setf selector (car args))
  504.             (setf args (cdr args))
  505.             (setf index (1+ index))
  506.  
  507.             (cond 
  508.                 ((and colon-modifier atsign-modifier)
  509.                     (error "~:@[ not allowed in format control string"))
  510.                 (atsign-modifier
  511.                     (progn))
  512.                 (colon-modifier                     
  513.                     (let ((ctstring 
  514.                             (if selector (cadr conditional-exprs) (car conditional-exprs))))
  515.                         (setf index (%format-list string-stream ctstring args))
  516.                         (setq string (get-output-stream-string string-stream))
  517.                         (write-string string stream)))
  518.                 (t 
  519.                     (let ((ctstring (nth selector conditional-exprs)))
  520.                         (setf index (%format-list string-stream ctstring args))
  521.                         (setq string (get-output-stream-string string-stream))
  522.                         (write-string string stream))))
  523.             index)))
  524.  
  525.  
  526. (%set-format-dispatch-func #\^
  527.     #'(lambda (stream args index atsign-modifier colon-modifier control)
  528.         (setq args (nthcdr index args))
  529.         (unless args (throw '%format-up-and-out nil))
  530.         index))
  531.  
  532. (%set-format-dispatch-func #\& 
  533.     #'(lambda (stream args index atsign-modifier colon-modifier control 
  534.                 &optional num)
  535.         (unless num (setq num 1))
  536.         (if (>= num 1)
  537.             (progn 
  538.                 (fresh-line stream)
  539.                 (dotimes (i (1- num))
  540.                     (terpri stream))))
  541.         index))
  542.  
  543. (%set-format-dispatch-func #\| 
  544.     #'(lambda (stream args index atsign-modifier colon-modifier control 
  545.                 &optional num)
  546.         (unless num (setq num 1))
  547.         (dotimes (i num)
  548.             (write-char (int-char 12) stream))
  549.         index))
  550.  
  551. (%set-format-dispatch-func #\Newline 
  552.     #'(lambda (stream args index atsign-modifier colon-modifier control)
  553.         ;; if atsign, process the newline
  554.         (if atsign-modifier
  555.             (terpri stream))
  556.         ;; skip whitespace
  557.         (unless colon-modifier
  558.             (do ((c (char (car control) (cadr control)) 
  559.                     (char (car control) (cadr control))))
  560.                 ((not (or (char= c #\Space) (char= c #\Tab))))
  561.                 (incf (cadr control)))
  562.             index)))
  563.  
  564. (%set-format-dispatch-func #\T 
  565.     #'(lambda (stream args index atsign-modifier colon-modifier control 
  566.                 &optional colnum colinc)
  567.         (unless colnum (setq colnum 1))
  568.         (unless colinc (setq colinc 1))
  569.         (if atsign-modifier
  570.             (progn
  571.                 (dotimes (i colnum)
  572.                     (write-char #\Space stream))
  573.                 (dotimes (i (- colinc (mod (stream-column stream) colinc)))
  574.                     (write-char #\Space stream)))
  575.             (let ((current-position (stream-column stream)))
  576.                 (if (> colnum current-position)
  577.                     (dotimes (i (- colnum current-position))
  578.                         (write-char #\Space stream))
  579.                     (if (> colinc 0)
  580.                         (dotimes (i (- colinc (mod (- current-position colnum) colinc)))
  581.                             (write-char #\Space stream))))))
  582.         index))
  583.  
  584. (%set-format-dispatch-func #\* 
  585.     #'(lambda (stream args index atsign-modifier colon-modifier control 
  586.                 &optional num)
  587.         (unless num (if atsign-modifier (setq num 0) (setq num 1)))
  588.         (if atsign-modifier
  589.             (return num))
  590.         (if colon-modifier (return (- index num)))
  591.         (return (+ index num))))
  592.  
  593. (defun %format-integer (stream int radix atsign-modifier colon-modifier 
  594.                 mincol padchar commachar)
  595.  
  596.         ;; initialize defaults
  597.         (unless mincol (setq mincol 0))
  598.         (setq padchar (if padchar (int-char padchar) #\Space))
  599.         (setq commachar (if commachar (int-char commachar) #\,))
  600.  
  601.         (let ((*print-base* radix)
  602.               (*print-radix* nil)
  603.               s
  604.               (length 0)
  605.               sign)
  606.  
  607.             (if (and atsign-modifier (plusp int))
  608.                 (progn (setf sign #\+) (incf length))
  609.                 (if (minusp int)
  610.                     (progn (setf sign #\-) (incf length) (setf int (- int)))))
  611.  
  612.             (setq s (with-output-to-string (x) (princ int x)))
  613.             (incf length (length s))
  614.             (if colon-modifier 
  615.                 (incf length (truncate (1- (length s)) 3)))
  616.             (if (< length mincol)
  617.                 (dotimes (i (- mincol length))
  618.                     (write-char padchar stream)))
  619.  
  620.             (if sign (write-char sign stream))
  621.  
  622.             (if colon-modifier
  623.                 (dotimes (i (length s))
  624.                     (write-char (char s i) stream)
  625.                     (let* ((digits-left (- (length s) (1+ i)))
  626.                            (digit-pos (mod digits-left 3)))
  627.                         (if (and (zerop digit-pos) (plusp digits-left))
  628.                             (write-char commachar stream))))
  629.                 (princ s stream))))  
  630.  
  631. (defconstant *format-cardinals*
  632.     #("zero" "one" "two" "three" "four" "five" "six" "seven" "eight" "nine" "ten"
  633.       "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety" "hundred"
  634.       "thousand" "million" "billion" "trillion"))
  635.  
  636. (defun %format-cardinal-number (int stream)
  637.         (if (zerop int) (return (princ "zero" stream)))
  638.         (if (minusp int) 
  639.             (progn (princ "negative " stream) (setq int (- int))))
  640.         (cond
  641.             ((< int 20)
  642.              (princ (nth int '("zero" "one" "two" "three" "four" "five" 
  643.                     "six" "seven" "eight" "nine" "ten" "eleven" "twelve" "thirteen"
  644.                     "fourteen" "fifteen" "sixteen" "seventeen" "eighteen" "nineteen")) 
  645.                 stream))
  646.             ((< int 100)
  647.              (princ (nth (- (truncate int 10) 2) '("twenty" "thirty" "forty"
  648.                             "fifty" "sixty" "seventy" "eighty" "ninety")) stream)
  649.              (if (plusp (mod int 10)) 
  650.                 (progn 
  651.                     (write-char #\- stream)
  652.                     (%format-cardinal-number (mod int 10) stream))))
  653.             ((< int 1000)
  654.              (%format-cardinal-number (truncate int 100) stream)
  655.              (princ " hundred" stream)
  656.              (if (plusp (mod int 100))
  657.                 (progn    
  658.                     (write-char #\Space stream)         
  659.                     (%format-cardinal-number (mod int 100) stream))))
  660.             ((< int 1000000)
  661.              (%format-cardinal-number (truncate int 1000) stream)
  662.              (princ " thousand" stream)
  663.              (if (plusp (mod int 1000))
  664.                 (progn    
  665.                     (write-char #\Space stream)         
  666.                     (%format-cardinal-number (mod int 1000) stream))))
  667.             ((< int 1000000000)
  668.              (%format-cardinal-number (truncate int 1000000) stream)
  669.              (princ " million" stream)
  670.              (if (plusp (mod int 1000000))
  671.                 (progn    
  672.                     (write-char #\Space stream)         
  673.                     (%format-cardinal-number (mod int 1000000) stream))))
  674.             (t (princ "billions"))))
  675.  
  676. (defun %format-ordinal-number (int stream)
  677.     (princ "Sorry" stream))
  678.  
  679. (defun %format-roman-numeral (int stream)
  680.     (princ "Sorry" stream))
  681.  
  682. (defun %format-old-roman-numeral (int stream)
  683.     (princ "Sorry" stream))
  684.  
  685.  
  686.  
  687.  
  688.  
  689.  
  690.  
  691.  
  692.  
  693.  
  694.  
  695.  
  696.  
  697.  
  698.  
  699.  
  700.  
  701.  
  702.  
  703.  
  704.  
  705.  
  706.